home *** CD-ROM | disk | FTP | other *** search
/ Trading on the Edge / Trading On The Edge - CD-ROM Toolkit (Wayzata Technology)(2031)(1994).bin / pc / mac_file / vendor_d / ga_softw / ooga / adaptive.lis next >
Lisp/Scheme  |  1991-02-03  |  14KB  |  420 lines
  1. ;;; -*- Mode:Lisp; Package:OOGA; Base:10; Syntax:COMMON-LISP -*-
  2. #||
  3.             RESTRICTED RIGHTS LEGEND
  4.                     
  5.  Use, duplication, or disclosure by the Government is subject to
  6.  restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
  7.  Technical Data and Computer Software Clause at 52.227-7013 of the DOD
  8.  FAR Supplement.
  9.                     
  10.                 TSP (The Software Partnership)
  11.                 P.O. Box 991
  12.                 Melrose, MA 02176
  13.                     
  14.       Copyright 1990 by Lawrence Davis and Daniel Cerys, all rights reserved.
  15. ||#
  16.  
  17. (in-package :ooga)
  18.  
  19.  
  20. ;;; This file contains methods related to the population module.
  21.  
  22.  
  23. ;;; VARIABLES
  24.  
  25.  
  26. (defvar *CURRENT-OPERATOR* nil "Operator being currently used")
  27.  
  28. (defvar *CURRENT-PARENTS* nil "Parents used by current operator")
  29.  
  30. (defvar *CURRENT-CHILDREN* nil "Children created by current operator")
  31.  
  32. (defvar *ADAPTIVE-DISPLAY-FLAG* t "Whether to display operator amounts")
  33.  
  34. ;;; Some SAFETY checks to warn the user of the possible conflict between
  35. ;;; using Adaptive Operators with either recycling and/or operator weight
  36. ;;; interpolation.  
  37.  
  38. (defmethod INITIALIZE-INSTANCE :AFTER
  39.        ((module adaptive-reproduction-module) &rest ignore)
  40.   (declare (ignore ignore))
  41.   (if *recycle-members-flag*
  42.       (format *standard-output*
  43.           "~%~%~%WARNING:  ADAPTIVE MODULE BEING USED WITH RECYCLING"))
  44.   (if (loop for technique in (parameterization-techniques module)
  45.         thereis (eq 'interpolate-operator-weights
  46.             (class-name (class-of technique))))
  47.       (format *standard-output*
  48.           "~%~%~%WARNING:  ADAPTIVE MODULE BEING USED ~%WITH OPERATOR WEIGHT INTERPOLATION")))
  49.  
  50. ;************************************************************
  51.  
  52. ;    LINEAGE TRACKING CLASSES AND METHODS
  53.  
  54.  
  55.  
  56. (defmethod INITIALIZE-FOR-RUN :AFTER ((lineage-tracker lineage-tracker))
  57.   "Initialize the lineage list"
  58.   (setf (lineage (lineage-list lineage-tracker)) nil))
  59.  
  60.  
  61. (defmethod APPLY-OPERATOR :BEFORE (operator (lineage-tracker lineage-tracker))
  62.   "Reset pointers to operator creation and children"
  63.   (setf *current-operator* operator
  64.     *current-children* nil
  65.     *current-parents* nil))
  66.  
  67.  
  68. (defmethod REPRODUCE :AROUND
  69.        ((technique reproduction-technique)
  70.         (module adaptive-reproduction-module))
  71.   "Unobtrusively set up children-parent pointers."
  72.   (let ((children (call-next-method technique module))
  73.      (population-module (population-module (ga module))))
  74.     (when children
  75.       (loop for child in children
  76.         with parents = *current-parents*
  77.         do (setf (parents child) parents))
  78.       (loop for parent in *current-parents*
  79.         do (setf (children parent) children))
  80.       (install-lineage-data population-module
  81.             *current-operator* children))
  82.     (setf *current-children* children)))
  83.  
  84.  
  85. (defmethod INSTALL-MEMBER :BEFORE
  86.        ((module adaptive-operator-module) member)
  87.   "Unobtrusively note local delta"
  88.     (if (and (> (current-index module)
  89.             (population-size module))
  90.          (first-member module)
  91.          (evaluation-better-p member (first-member module)))
  92.         (setf (local-delta member)
  93.            (abs (- (evaluation member)
  94.                (evaluation (first-member module)))))))
  95.  
  96.  
  97. (defmethod GET-PARENT :AROUND
  98.        ((parent-selection-technique parent-selection-technique))
  99.    "Track the parents"
  100.    (let ((parent (call-next-method parent-selection-technique)))
  101.      (setf *current-parents* (cons parent *current-parents*))
  102.      parent))
  103.  
  104.  
  105. (defmethod INSTALL-LINEAGE-DATA
  106.        ((module lineage-tracker) operator children)
  107.   "Do bookkeeping and set up an alist with the operators as keys"
  108.   (let* ((lineage-list (lineage (lineage-list module)))
  109.      (list (assoc operator lineage-list)))
  110.     (if list
  111.     (rplacd list (append children (cdr list)))
  112.     (setf (lineage (lineage-list module))
  113.           (push (cons operator children) lineage-list)))
  114.     ))
  115.  
  116.  
  117.  
  118. ;************************************************************
  119.  
  120. ;    OPERATOR ADAPTATION METHODS
  121.  
  122.  
  123.  
  124. (defmethod TOTAL-DELTA ((member adaptation-population-member))
  125.   "Sum the local and inherited delta"
  126.   (+ (local-delta member)
  127.      (inherited-delta member)))
  128.  
  129.  
  130. (defmethod INITIALIZE-FOR-RUN :AFTER ((module adaptive-operator-module))
  131.   "Initialize the next adaptation variable"
  132.   (setf (next-adaptation module)
  133.     (+ (population-size module)
  134.        (adaptation-interval module)))
  135.   (setf (operator-weights (reproduction-module (ga module)))
  136.     (initial-operator-weights module)))
  137.  
  138.  
  139. (defmethod INSERT-POPULATION-MEMBERS :AFTER ((module adaptive-operator-module) members)
  140.   "Do bookkeeping on best-member deltas"
  141.   (declare (ignore members))
  142.   (if (>= (current-index module)
  143.       (next-adaptation module))
  144.       (carry-out-adaptation module))
  145.   )
  146.  
  147.  
  148. (defmethod CARRY-OUT-ADAPTATION ((module adaptive-operator-module))
  149.   "Modify the operator weights and set the time for the next adaptation"
  150.   (adapt-operator-weights module)
  151.   (setf (next-adaptation module)
  152.     (do ((adaptation (adaptation-interval module)
  153.              (+ adaptation (adaptation-interval module))))
  154.         ((> adaptation (current-index module)) adaptation))))
  155.  
  156.  
  157. (defmethod ADAPT-OPERATOR-WEIGHTS ((module adaptive-operator-module))
  158.   "Adapt the relative weights of the operators using the procedure described in Chapter 6 of the Handbook."
  159.   (if *adaptive-display-flag*
  160.       (format t "~%~%Adapting weights at ~a with best value ~a:~%~a"
  161.           (current-index module)
  162.           (evaluation (first-member module))
  163.           (loop for weight in
  164.             (operator-weights (reproduction-module (ga module)))
  165.             collect (round weight))))
  166.   (let* ((old-weights (operator-weights (reproduction-module (ga module))))
  167.      (factor (/ (- 100 (adaptive-delta-amount module)) 100.0)))
  168.     (compute-member-deltas module (get-current-members module))
  169.     (let* ((deltas (compute-operator-deltas module))
  170.        (normalized-deltas
  171.          (normalize-total deltas
  172.                   (adaptive-delta-amount module))))
  173.       (do ((old old-weights (cdr old))
  174.        (new-weights nil)
  175.        (modifiers normalized-deltas (cdr modifiers)))
  176.       ((null old)
  177.        (progn (setf (operator-weights (reproduction-module (ga module)))
  178.             (normalize-total (nreverse new-weights) 100))))
  179.     (setf new-weights (cons (max (minimum-operator-weight module)
  180.                      (+ (car modifiers)
  181.                     (* (car old) factor)))
  182.                 new-weights)))
  183.       (if *adaptive-display-flag*
  184.       (format t "~%~a~%~a"
  185.           deltas
  186.           (loop for weight in
  187.                 (operator-weights (reproduction-module (ga module)))
  188.             collect (round weight))))
  189.       )))
  190.  
  191.  
  192. (defmethod GET-CURRENT-MEMBERS ((module adaptive-operator-module))
  193.   "Get the current members of the population for adapting operator weights"
  194.   (loop for operator-alist in (lineage (lineage-list module))
  195.     with first-index = (- (current-index module)
  196.                   (adaptation-window module))
  197.     append (loop for member in (cdr operator-alist)
  198.              until (and (index member)
  199.                 (< (index member) first-index))
  200.              when (index member) collect member)))
  201.  
  202.  
  203. (defmethod COMPUTE-OPERATOR-DELTAS ((module adaptive-operator-module))
  204.   "Compute the deltas of the operators.  Assumption is that the
  205.    deltas of the members have been computed."
  206.   (loop for operator in (operator-list (reproduction-module (ga module)))
  207.     collect (operator-delta module operator)))
  208.  
  209.  
  210. (defmethod COMPUTE-MEMBER-DELTAS ((module adaptive-operator-module) members)
  211.   "Compute the deltas of the members"
  212.   (clear-member-deltas module members)
  213.   (loop for member in members
  214.     do (compute-inherited-delta member
  215.                     (inherited-delta-scalar module)
  216.                     (inherited-delta-generations module))))
  217.  
  218.  
  219. (defmethod CLEAR-MEMBER-DELTAS ((module adaptive-operator-module) members)
  220.   "Reset delta slots in members"
  221.   (loop for x in members
  222.     do (setf (inherited-delta x) 0)))
  223.  
  224.  
  225.  
  226. (defmethod COMPUTE-LOCAL-DELTA ((member adaptation-population-member) more-is-better?)
  227.   "Compute the difference between the evaluation and the best parent's evaluation"
  228.   (if more-is-better? 
  229.       (max 0 (- (evaluation member)
  230.         (loop for parent in (parents member)
  231.               maximize (evaluation parent))))
  232.       (max 0 (- (loop for parent in (parents member)
  233.               minimize (evaluation parent))
  234.         (evaluation member)))))
  235.  
  236.  
  237. (defmethod COMPUTE-INHERITED-DELTA
  238.        ((member adaptation-population-member) scalar generations)
  239.   "Pass back part of the delta to preceding generations, damping the amount by 
  240.    the scalar and apportioning it among the parents equably"
  241.   (if (and (parents member) (not (= (local-delta member) 0)))
  242.       (loop for parent in (parents member)
  243.         with amount = (* scalar
  244.                  (/ (local-delta member)
  245.                 (float (length (parents member)))))
  246.         do (add-inherited-delta parent amount scalar (1- generations)))))
  247.  
  248.  
  249. (defmethod ADD-INHERITED-DELTA
  250.        ((member adaptation-population-member) amount scalar generations)
  251.   "Pass the inherited delta back to progenitors."
  252.   (if (> generations 0)
  253.       (progn (setf (inherited-delta member) (+ (inherited-delta member) amount))
  254.          (if (parents member)
  255.          (loop for parent in (parents member)
  256.                with new-amount = (* scalar
  257.                         (/ amount
  258.                            (float
  259.                          (length (parents member)))))
  260.                do (add-inherited-delta
  261.                 parent new-amount scalar (1- generations)))))))
  262.  
  263.  
  264. (defmethod OPERATOR-DELTA ((module adaptive-operator-module) operator)
  265.   "Get the average total delta for the operator"
  266.   (let* ((first-index (- (current-index module)
  267.                   (adaptation-window module)))
  268.      (current-members
  269.        (loop for member in (cdr (assoc operator
  270.                        (lineage (lineage-list module))))
  271.          until (and (index member)
  272.                 (< (index member) first-index))
  273.          when (index member) collect member)))
  274.     (if current-members
  275.     (/ (loop for member in current-members
  276.          summing (total-delta member))
  277.        (float (length current-members)))
  278.     0)))
  279.  
  280.  
  281. ;************************************************************
  282.  
  283. ;    ADAPTIVE OPERATOR WEIGHT TRACING
  284.  
  285.  
  286. ;;;Used to trace weight history over multiple runs.
  287.  
  288. (defclass TRACE-OPERATOR-WEIGHTS (adaptive-operator-module)
  289.      ((OPERATOR-WEIGHT-HISTORY :initarg :operator-weight-history
  290.                    :initform nil :accessor operator-weight-history)
  291.       ))
  292.  
  293.  
  294. (defmethod INITIALIZE-POPULATION :after ((module trace-operator-weights)) 
  295.   "Maintain the operator weight history slot"
  296.   (setf (operator-weight-history module)
  297.     (push (list (list (current-index module)
  298.               (operator-weights
  299.                 (reproduction-module (ga module)))))
  300.           (operator-weight-history module))))
  301.  
  302.  
  303. (defmethod ADAPT-OPERATOR-WEIGHTS :AFTER ((module trace-operator-weights))
  304.   "Add information to the operator weight history slot"
  305.   (push (list (current-index module)
  306.           (operator-weights
  307.         (reproduction-module (ga module))))
  308.     (car (operator-weight-history module))))
  309.  
  310.  
  311. (defmethod AVERAGE-OPERATOR-WEIGHTS ((module trace-operator-weights))
  312.   "Find average weights at different run stages"
  313.   (loop with history = (operator-weight-history module)
  314.     for stage in (car history)
  315.     collect (average-weights-at-stage stage history)))
  316.  
  317.  
  318. ;************************************************************
  319.  
  320. ;    ADAPTIVE OPERATOR WEIGHT INITIALIZATION 
  321.  
  322.  
  323. (defvar *INITIAL-DELTAS* nil "Deltas for successive populations")
  324.  
  325.  
  326. ;;;THIS CLASS IS TO BE COMBINED WITH GENETIC ALGORITHM CLASSES.
  327. (defclass ADAPT-INITIAL-OPERATOR-WEIGHTS ()
  328.      ())
  329.  
  330.  
  331. (defmethod FIND-INITIAL-OPERATOR-WEIGHTS
  332.        ((ga adapt-initial-operator-weights)
  333.         &optional (cycles 10)
  334.         (number-to-generate 200))
  335.   (initialize-for-run ga)
  336.   (setf *initial-deltas*
  337.   (loop repeat cycles
  338.     collect (adapt-initial-operator-weights
  339.           ga number-to-generate)))
  340.   (display-final-average ga *initial-deltas*))
  341.  
  342.  
  343. (defmethod DISPLAY-FINAL-AVERAGE
  344.        ((ga adapt-initial-operator-weights) final-deltas)
  345.   (format *standard-output*
  346.       "~%~%~%AVERAGE DELTA FOR ~a CYCLES:" (length final-deltas))
  347.   (loop for deltas in final-deltas do (print deltas))
  348.   (let ((initial-weights
  349.       (normalize (parallel-average
  350.                (loop for deltas in final-deltas
  351.                  collect (normalize deltas
  352.                             (/ 100.0 (length deltas)))))
  353.              (/ 100.0 (length (car final-deltas))))))
  354.     (format *standard-output*
  355.         "~%~%INITIAL OPERATOR WEIGHTS BASED ON AVERAGE DELTA:~%  ~a"
  356.         initial-weights)
  357.     initial-weights))
  358.  
  359.  
  360. ;;; Algorithm for finding initial weights.  Superior
  361. ;;; to that in the Handbook.  Replaces the algorithm in the Handbook.
  362.  
  363. (defmethod ADAPT-INITIAL-OPERATOR-WEIGHTS
  364.        ((ga adapt-initial-operator-weights)
  365.         number-to-run)
  366.   (initialize-population (population-module ga))
  367.   (format t "~%~%Best eval = ~a"
  368.       (evaluation (first-member (population-module ga))))
  369.   (let ((population-module (population-module ga))
  370.     (reproduction-module (reproduction-module ga)))
  371.     (if *adaptive-display-flag*
  372.     (format *standard-output*
  373.         "~%~%Deltas for ~a new members:" number-to-run))
  374.     (loop for operator in
  375.           (operator-list reproduction-module)
  376.       for new-members = (n-new-members number-to-run
  377.                        operator
  378.                        population-module)
  379.       with deltas = nil
  380.       do (loop for member in new-members
  381.            do (setf (evaluation member)
  382.                 (evaluate-member
  383.                   (evaluator (evaluation-module ga))
  384.                   member)))
  385.          (let ((new-deltas
  386.              (/ (loop for member in new-members
  387.                   summing (if (evaluation-better-p
  388.                         member
  389.                         (first-member population-module))
  390.                       (abs (- (evaluation member)
  391.                           (evaluation
  392.                             (first-member
  393.                               population-module))))
  394.                       0))
  395.             (float (length new-members)))))
  396.            (if *adaptive-display-flag*
  397.            (format *standard-output* "~%Deltas for ~a = ~a"
  398.                (class-name (class-of operator)) new-deltas))
  399.            (setf deltas (cons new-deltas deltas)))
  400.       finally (return (reverse deltas)))))
  401.  
  402.  
  403. (defmethod N-NEW-MEMBERS
  404.        (n (operator ga-operator) (population-module basic-population-module))
  405.   (loop with new-chromosomes = nil
  406.     until (>= (length new-chromosomes) n)
  407.     do (setf new-chromosomes
  408.          (append (apply-operator operator population-module)
  409.              new-chromosomes))
  410.     finally (return
  411.           (loop for chromosome in new-chromosomes
  412.             for member =
  413.                 (create-population-member
  414.                   (initialization-technique population-module)
  415.                   (representation-technique population-module))
  416.             with new-members = nil
  417.             do (setf (chromosome member) chromosome
  418.                  new-members (cons member new-members))
  419.             finally (return new-members)))))
  420.